home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / Pascal / Snippets / PNL Libraries / MyThreads.p < prev    next >
Encoding:
Text File  |  1997-01-10  |  2.2 KB  |  100 lines  |  [TEXT/CWIE]
  1. unit MyThreads;
  2.  
  3. interface
  4.  
  5.     uses
  6.         Types, Threads;
  7.  
  8.     var
  9.         active_threads: integer; { YOU MUST DECREMENT active_threads }
  10.         threads_must_die:Boolean;
  11.         has_ThreadManager: boolean;
  12.  
  13.     procedure StartupThreads;
  14.     procedure FinishMyThreads;{ waits for all threads to complete - ie active_threads=0 }
  15.     function MyNewThread (proc: ThreadEntryProcPtr; threadParam: univ Ptr; stack: longint):OSErr; { increments active_thread }
  16.     procedure MyThreadDied; { call when your thread dies to decrement active_threads }
  17.     procedure MyYield;
  18.  
  19. implementation
  20.  
  21.     uses
  22.         Events, GestaltEqu, CodeFragments, 
  23.         MyAssertions, MySystemGlobals, MyStartup, MyUtils;
  24.  
  25.     const
  26.         our_thread_stack = 12288;
  27.         our_thread_options = kCreateIfNeeded + kUsePremadeThread + kFPUNotNeeded;
  28.  
  29.     procedure MyThreadDied;
  30.     begin
  31.         Dec(active_threads);
  32.     end;
  33.     
  34.     function MyNewThread (proc: ThreadEntryProcPtr; threadParam: univ Ptr; stack: longint):OSErr;
  35.         var
  36.             err:OSErr;
  37.             thread: ThreadID;
  38.     begin
  39.         if stack = 0 then begin
  40.             stack := our_thread_stack;
  41.         end;
  42.         if not has_ThreadManager then begin
  43.             err := -1;
  44.         end else begin
  45.             err := NewThread(kCooperativeThread, proc, threadParam, stack, our_thread_options, nil, thread);
  46.         end;
  47.         if err = noErr then begin
  48.             active_threads := active_threads + 1;
  49.         end;
  50.         MyNewThread := err;
  51.     end;
  52.  
  53.     procedure MyYield;
  54.         var
  55.             junk: OSErr;
  56.     begin
  57.         if has_ThreadManager then begin
  58.             junk := YieldToAnyThread;
  59.             Assert( junk = noErr );
  60.         end;
  61.     end;
  62.  
  63.     function HasThreadLib: boolean;
  64.     begin
  65. {$IFC GENERATINGPOWERPC}
  66.         HasThreadLib := longint(@NewThread) <> kUnresolvedCFragSymbolAddress;
  67. {$ELSEC}
  68.         HasThreadLib := true;
  69. {$ENDC}
  70.     end;
  71.  
  72.     function InitThread(var msg: integer): OSStatus;
  73.         var
  74.             gv: longint;
  75.     begin
  76. {$unused(msg)}
  77.         active_threads := 0;
  78.         has_ThreadManager := (Gestalt(gestaltThreadMgrAttr, gv) = noErr) & (btst(gv, gestaltThreadMgrPresent)) & HasThreadLib;
  79.         InitThread := noErr;
  80.     end;
  81.     
  82.     procedure FinishMyThreads;{ waits for all threads to complete - ie active_threads=0 }
  83.         var
  84.             er: EventRecord;
  85.             dummy: boolean;
  86.     begin
  87.         threads_must_die := true;
  88.         while active_threads > 0 do begin
  89.             dummy := WaitNextEvent(everyEvent, er, 0, nil);
  90.             MyYield;
  91.         end;
  92.     end;
  93.  
  94.     procedure StartupThreads;
  95.     begin
  96.         SetStartup(InitThread, nil, 0, FinishMyThreads);
  97.     end;
  98.     
  99. end.
  100.